home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 3 / CD ACTUAL 3.iso / linux / incoming / jstools-.6v3 / jstools- / jstools-tk3.6v3.0 / lib / jtkutils.tcl < prev    next >
Encoding:
Text File  |  1995-02-09  |  9.9 KB  |  324 lines
  1. # jtkutils.tcl - general utilities requiring Tk
  2. # 
  3. # Copyright 1992-1994 by Jay Sekora.  All rights reserved, except 
  4. # that this file may be freely redistributed in whole or in part 
  5. # for non¡profit, noncommercial use.
  6. ######################################################################
  7.  
  8. ### TO DO
  9. ###   j:rule and j:filler should read defaults for size, colour, etc.
  10.  
  11. ######################################################################
  12. # global variables:
  13. #
  14. global J_PREFS env
  15. if {! [info exists J_PREFS(autoposition)]} {set J_PREFS(autoposition) 0}
  16. if {! [info exists J_PREFS(confirm)]} {set J_PREFS(confirm) 1}
  17. if { ! [info exists J_PREFS(visiblebell)]} {set J_PREFS(visiblebell) 1}
  18. if { ! [info exists J_PREFS(audiblebell)]} {set J_PREFS(audiblebell) 1}
  19. #
  20. ######################################################################
  21.  
  22. ######################################################################
  23. # metawidget options:
  24. #
  25. option add *Rule.relief sunken widgetDefault
  26. option add *Rule.width 2 widgetDefault
  27. option add *Rule.height 2 widgetDefault
  28. option add *Rule.borderWidth 1 widgetDefault
  29. option add *Filler.relief flat widgetDefault
  30. option add *Filler.width 10 widgetDefault
  31. option add *Filler.height 10 widgetDefault
  32.  
  33. ######################################################################
  34. # j:wm_client - set the session client hostname
  35. ######################################################################
  36.  
  37. proc j:wm_client {{hostname USE_HOSTNAME}} {
  38.   if {"x$hostname" == "xUSE_HOSTNAME"} {
  39.     set hostname localhost
  40.     set hostname_cmd FAIL
  41.     foreach pathname {
  42.       /bin/hostname
  43.       /etc/hostname
  44.       /usr/etc/hostname
  45.       /usr/bsd/hostname
  46.       /usr/bin/hostname
  47.       /usr/ucb/hostname
  48.     } {
  49.       if [auto_execok $pathname] {
  50.         set hostname_cmd $pathname
  51.         break
  52.       }
  53.     }
  54.     if {"x$hostname_cmd" == "xFAIL"} {
  55.       j:alert \
  56.         -text "Can't determine hostname; can't find `hostname' to execute."
  57.     } else {
  58.       if [catch {exec hostname} result] {
  59.         j:alert -text "Can't determine hostname:\n$result"
  60.       } else {
  61.         set hostname $result
  62.       }
  63.     }
  64.   }
  65.   wm client . $hostname
  66. }
  67.  
  68. ######################################################################
  69. # j:wm_command ?args? - set the session client command
  70. ######################################################################
  71.  
  72. proc j:wm_command {{command ""}} {
  73.   global argv0 argv
  74.   
  75.   if {[llength $command] == 0} {
  76.     set command [concat $argv0 $argv]
  77.   }
  78.   
  79.   wm command . $command
  80. }
  81.  
  82. ######################################################################
  83. # j:new_toplevel prefix ?args? -
  84. #   create a new toplevel, avoiding name conflicts
  85. ######################################################################
  86.  
  87. proc j:new_toplevel { prefix args } {
  88.   set count 0
  89.   
  90.   while {[winfo exists $prefix$count]} {
  91.     incr count
  92.   }
  93.   
  94.   set tl $prefix$count
  95.   toplevel $tl
  96.   
  97.   if {"x$args" != "x"} {
  98.     eval [list $tl configure] $args
  99.   }
  100.   return $tl
  101. }
  102.  
  103. ######################################################################
  104. # j:selection_if_any - return selection if it exists, else {}
  105. #   this is from R. James Noble <kjx@comp.vuw.ac.nz>
  106. ######################################################################
  107.  
  108. proc j:selection_if_any {} {
  109.   if {[catch {selection get} s]} {return ""} {return $s}
  110. }
  111.  
  112. ######################################################################
  113. # j:beep w - "ring bell" in widget W
  114. ######################################################################
  115.  
  116. proc j:beep { w } {
  117.   global j_beep J_PREFS
  118.   
  119.   set delay 100                ;# should be a preference
  120.   
  121.   if { ! [info exists j_beep($w)] } {
  122.     set j_beep($w) 0
  123.   }
  124.   
  125.   if $j_beep($w) {
  126.     return 1
  127.   }
  128.   set j_beep($w) 1            ;# used so bells don't queue up
  129.   
  130.   if $J_PREFS(visiblebell) {
  131.     set fg black
  132.     set bg white
  133.     
  134.     if ![catch {set fg [lindex [$w configure -foreground] 4]}] {
  135.       catch {$w configure -foreground $bg}
  136.       after $delay "catch {$w configure -foreground $fg}"
  137.     }
  138.     if ![catch {set bg [lindex [$w configure -background] 4]}] {
  139.       catch {$w configure -background $fg}
  140.       after $delay "catch {$w configure -background $bg}"
  141.     }
  142.     update
  143.     after $delay "
  144.       update
  145.       set j_beep($w) 0
  146.     "
  147.   }
  148.   if $J_PREFS(audiblebell) {
  149.     j:tk4 {bell -displayof $w}
  150.   }
  151.   
  152.   after $delay "set j_beep($w) 0"    ;# allow processing future bells
  153.   
  154.   return 0
  155. }
  156.  
  157. ######################################################################
  158. # j:no_selection - true if there is no selection
  159. ######################################################################
  160.  
  161. proc j:no_selection {} {
  162.   if {[catch {selection get} s]} {return 1} {return 0}
  163. }
  164.  
  165. ######################################################################
  166. # j:default_button button widget... - bind <Return> to default button
  167. #   widget... is one or more widgets that can have the kbd focus
  168. ######################################################################
  169.  
  170. proc j:default_button { button args } {
  171.   foreach w $args {
  172.     bind $w <Return> "$button invoke"
  173.   }
  174. }
  175.  
  176. ######################################################################
  177. # j:cancel_button button widget... - set up bindings for cancel button
  178. #   widget... is one or more widgets that can have the kbd focus
  179. ######################################################################
  180.  
  181. proc j:cancel_button { button args } {
  182.   foreach w $args {
  183.     bind $w <Control-c> "$button invoke"
  184.     bind $w <Control-g> "$button invoke"
  185.     bind $w <Meta-q> "$button invoke"
  186.     bind $w <Meta-period> "$button invoke"
  187.   }
  188. }
  189.  
  190. ######################################################################
  191. # j:tab_ring widget... - bind Tab and Shift-Tab to cycle through widgets
  192. #  widget... is the list of widgets to bind, in order
  193. ######################################################################
  194. ### It's unfortunate to have to hardwire Shift-Tab to Backtab, but there
  195. ### doesn't seem to be a <Backtab> X11 keysym.
  196.  
  197. proc j:tab_ring {args} {
  198.   # index of last widget
  199.   set last [expr {[llength $args] - 1}]
  200.   
  201.   for {set i 0} {$i < $last} {incr i} {
  202.     set this [lindex $args $i]
  203.     set next [lindex $args [expr {$i + 1}]]
  204.     bind $this <Tab> "focus $next"
  205.     bind $next <Shift-Tab> "focus $this"
  206.   }
  207.   
  208.   # ... and bind last to focus on first:
  209.   set this [lindex $args $last]
  210.   set next [lindex $args 0]
  211.   bind $this <Tab> "focus $next"
  212.   bind $next <Shift-Tab> "focus $this"
  213. }
  214.  
  215. ######################################################################
  216. # j:dialogue w - arrange to position window w near ctr of screen
  217. #   mostly borrowed from /usr/local/lib/tk/dialog.tcl
  218. # does nothing unless $J_PREFS(autoposition)
  219. ######################################################################
  220.  
  221. proc j:dialogue { w } {
  222.   global J_PREFS
  223.  
  224.   if $J_PREFS(autoposition) {
  225.     # first, display off-screen:
  226.     wm withdraw $w        ;# hide the window
  227.  
  228.     update idletasks        ;# force geometry managers to run
  229.     # calculate position:
  230.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  231.         - [winfo vrootx [winfo parent $w]]]
  232.     set y [expr [winfo screenheight $w]/3 - [winfo reqheight $w]/2 \
  233.         - [winfo vrooty [winfo parent $w]]]
  234.     wm geom $w +$x+$y
  235.     wm deiconify $w
  236.  
  237.     update idletasks        ;# force geometry managers to run
  238.     wm deiconify $w        ;# display window
  239.     wm focus $w
  240.   }
  241. }
  242.  
  243. proc j:dialog [info args j:dialogue] [info body j:dialogue]
  244.  
  245. ######################################################################
  246. # j:rule parent [args] - returns a rule suitable for parent
  247. #       used as argument to a pack command
  248. ######################################################################
  249.  
  250. proc j:rule { {parent {}} args} {
  251.   global j_rule
  252.  
  253.   if {$parent == "."} {set parent ""}    ;# so "." doesn't give "..rule0"
  254.   
  255.   if {[info exists j_rule(count)]} then {
  256.     set j_rule(count) [expr {$j_rule(count) + 1}]
  257.   } else {
  258.     set j_rule(count) 0
  259.   }
  260.  
  261.   set rule "$parent.rule$j_rule(count)"
  262.   frame $rule -class Rule
  263.   if {$args != ""} {eval $rule configure $args}
  264.   return $rule
  265. }
  266.  
  267. ######################################################################
  268. # j:filler parent [args] - returns a filler frame suitable for parent
  269. #       used as argument to a pack command
  270. ######################################################################
  271.  
  272. proc j:filler { {parent {}} args} {
  273.   global j_filler
  274.  
  275.   if {$parent == "."} {set parent ""}    ;# so "." doesn't give "..filler0"
  276.   
  277.   if {[info exists j_filler(count)]} then {
  278.     set j_filler(count) [expr {$j_filler(count) + 1}]
  279.   } else {
  280.     set j_filler(count) 0
  281.   }
  282.  
  283.   set filler "$parent.filler$j_filler(count)"
  284.   frame $filler -class Filler
  285.   if {$args != ""} {eval $filler configure $args}
  286.   return $filler
  287. }
  288.  
  289. ######################################################################
  290. # j:configure_font widget fontlist - use font from list, or default
  291. #   tries to set widget's font to each font in list.
  292. #   if a font is `default', tries to set to X default font.
  293. #   if a font is {}, sets to courier 12-point.
  294. ######################################################################
  295.  
  296. proc j:configure_font { widget fontlist } {
  297.   foreach font $fontlist {
  298.     # try to use each font, until one is successful:
  299.     if {$font == {default}} {
  300.       set font [option get $widget font Font]
  301.       if {$font == {}} {set font {*-courier-medium-r-normal--*-120-*}}
  302.     }
  303.     if {! [catch {$widget configure -font $font}]} {return}
  304.   }
  305. }
  306.  
  307. ######################################################################
  308. # j:configure_tag_font widget tag fontlist - use font from list, or default
  309. #   tries to set tag's font to each font in list.
  310. #   if a font is `default', tries to set to X default font.
  311. #   if a font is {}, sets to courier 12-point.
  312. ######################################################################
  313.  
  314. proc j:configure_tag_font { widget tag fontlist } {
  315.   foreach font $fontlist {
  316.     # try to use each font, until one is successful:
  317.     if {$font == {default}} {
  318.       set font [option get $widget font Font]
  319.       if {$font == {}} {set font {*-courier-medium-r-normal--*-120-*}}
  320.     }
  321.     if {! [catch {$widget tag configure $tag -font $font}]} {return}
  322.   }
  323. }
  324.